home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / extensions.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  18.9 KB  |  571 lines
  1. ;;; -*- Log: code.log; Package: Extensions -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: extensions.lisp,v 1.13 91/11/06 19:46:08 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Spice Lisp extensions to the language.
  15. ;;;
  16. ;;; Letf written by Steven Handerson.
  17. ;;;
  18. ;;; **********************************************************************
  19. (in-package "EXTENSIONS")
  20.  
  21. (export '(letf* letf dovector deletef indenting-further file-comment
  22.         read-char-no-edit listen-skip-whitespace concat-pnames
  23.         iterate once-only collect do-anonymous undefined-value
  24.         required-argument define-hash-cache defun-cached
  25.         cache-hash-eq))
  26.  
  27. (import 'lisp::whitespace-char-p)
  28.  
  29.  
  30.  
  31. ;;; Undefined-Value  --  Public
  32. ;;;
  33. ;;;    This is here until we figure out what to do with it.
  34. ;;;
  35. (proclaim '(inline undefined-value))
  36. (defun undefined-value ()
  37.   '%undefined%)
  38.  
  39. ;;; REQUIRED-ARGUMENT  --  Public
  40. ;;;
  41. (proclaim '(ftype (function () nil) required-argument))
  42. (defun required-argument ()
  43.   "This function can be used as the default value for keyword arguments that
  44.   must be always be supplied.  Since it is known by the compiler to never
  45.   return, it will avoid any compile-time type warnings that would result from a
  46.   default value inconsistent with the declared type.  When this function is
  47.   called, it signals an error indicating that a required keyword argument was
  48.   not supplied.  This function is also useful for DEFSTRUCT slot defaults
  49.   corresponding to required arguments."
  50.   (error "A required keyword argument was not supplied."))
  51.  
  52.  
  53. ;;; FILE-COMMENT  --  Public
  54. ;;;
  55. (defmacro file-comment (string)
  56.   "FILE-COMMENT String
  57.   When COMPILE-FILE sees this form at top-level, it places the constant string
  58.   in the run-time source location information.  DESCRIBE will print the file
  59.   comment for the file that a function was defined in.  The string is also
  60.   textually present in the FASL, so the RCS \"ident\" command can find it,
  61.   etc."
  62.   (declare (ignore string))
  63.   '(undefined-value))
  64.  
  65.  
  66. (defun skip-whitespace (&optional (stream *standard-input*))
  67.   (loop (let ((char (read-char stream)))
  68.       (if (not (lisp::whitespacep char))
  69.           (return (unread-char char stream))))))
  70.  
  71.   
  72. (defun listen-skip-whitespace (&optional (stream *standard-input*))
  73.   "See listen.  Any whitespace in the input stream will be flushed."
  74.   (do ((char (read-char-no-hang stream nil nil nil)
  75.          (read-char-no-hang stream nil nil nil)))
  76.       ((null char) nil)
  77.     (cond ((not (whitespace-char-p char))
  78.        (unread-char char stream)
  79.        (return T)))))
  80.  
  81. ;;; These macros waste time as opposed to space.
  82.  
  83. (defmacro letf* (bindings &body body &environment env)
  84.   "Does what one might expect, saving the old values and setting the generalized
  85.   variables to the new values in sequence.  Unwind-protects and get-setf-method
  86.   are used to preserve the semantics one might expect in analogy to let*,
  87.   and the once-only evaluation of subforms."
  88.   (labels ((do-bindings
  89.         (bindings)
  90.         (cond ((null bindings) body)
  91.           (t (multiple-value-bind (dummies vals newval setter getter)
  92.                       (get-setf-method (caar bindings) env)
  93.                (let ((save (gensym)))
  94.              `((let* (,@(mapcar #'list dummies vals)
  95.                   (,(car newval) ,(cadar bindings))
  96.                   (,save ,getter))
  97.                  (unwind-protect
  98.                    (progn ,setter
  99.                       ,@(do-bindings (cdr bindings)))
  100.                    (setq ,(car newval) ,save)
  101.                    ,setter)))))))))
  102.     (car (do-bindings bindings))))
  103.  
  104.  
  105. (defmacro letf (bindings &body body &environment env)
  106.   "Like letf*, but evaluates all the implicit subforms and new values of all
  107.   the implied setfs before altering any values.  However, the store forms
  108.   (see get-setf-method) must still be evaluated in sequence.  Uses unwind-
  109.   protects to protect the environment."
  110.   (let (temps)
  111.     (labels
  112.       ((do-bindings
  113.     (bindings)
  114.     (cond ((null bindings) body)
  115.           (t (let ((binding (car bindings)))
  116.            (multiple-value-bind (dummies vals newval setter getter)
  117.                     (get-setf-method (car binding) env)
  118.              (let ((save (gensym)))
  119.                (mapcar #'(lambda (a b) (push (list a b) temps))
  120.                    dummies vals) 
  121.                (push (list save getter) temps)
  122.                (push (list (car newval) (cadr binding)) temps)
  123.                `((unwind-protect
  124.                (progn ,setter
  125.                   ,@(do-bindings (cdr bindings)))
  126.                (setq ,(car newval) ,save)
  127.                ,setter)))))))))
  128.       (let ((form (car (do-bindings bindings))))
  129.     `(let* ,(nreverse temps)
  130.        ,form)))))
  131.  
  132.  
  133. (define-setf-method logbitp (index int &environment env)
  134.   (multiple-value-bind (temps vals stores store-form access-form)
  135.                (get-setf-method int env)
  136.     (let ((ind (gensym))
  137.       (store (gensym))
  138.       (stemp (first stores)))
  139.       (values `(,ind ,@temps)
  140.           `(,index
  141.         ,@vals)
  142.           (list store)
  143.           `(let ((,stemp
  144.               (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
  145.          ,store-form
  146.          ,store)
  147.           `(logbitp ,ind ,access-form)))))
  148.  
  149.  
  150. ;;; Indenting-Further is a user-level macro which may be used to locally increment
  151. ;;; the indentation of a stream.
  152.  
  153. (defmacro indenting-further (stream more &rest body)
  154.   "Causes the output of the indenting Stream to indent More spaces.  More is
  155.   evaluated twice."
  156.   `(unwind-protect
  157.      (progn
  158.       (incf (lisp::indenting-stream-indentation ,stream) ,more)
  159.       ,@body)
  160.      (decf (lisp::indenting-stream-indentation ,stream) ,more)))
  161.  
  162.  
  163. ;;; Deletef
  164.  
  165. (defmacro deletef (elt list &rest keys &environment env)
  166.   (multiple-value-bind (dummies vals newval setter getter)
  167.                (get-setf-method list env)
  168.     (let ((eltsym (gensym))
  169.       (listsym (gensym)))
  170.       `(let* ((,eltsym ,elt)
  171.           ,@(mapcar #'list dummies vals)
  172.           (,listsym ,getter)
  173.           (,(car newval) (delete ,eltsym ,listsym ,@keys)))
  174.      ,setter))))
  175.  
  176.  
  177. (defmacro dovector ((elt vector) &rest forms)
  178.   "Just like dolist, but with one-dimensional arrays."
  179.   (let ((index (gensym))
  180.     (length (gensym))
  181.     (vec (gensym)))
  182.     `(let ((,vec ,vector))
  183.        (do ((,index 0 (1+ ,index))
  184.         (,length (length ,vec)))
  185.        ((>= ,index ,length) nil)
  186.      (let ((,elt (aref ,vec ,index)))
  187.        ,@forms)))))
  188.  
  189.  
  190. (eval-when (compile load eval)
  191.   (defun concat-pnames (name1 name2)
  192.     (declare (symbol name1 name2))
  193.     (if name1
  194.     (intern (concatenate 'simple-string (symbol-name name1)
  195.                  (symbol-name name2)))
  196.     name2)))
  197.  
  198.  
  199. ;;; Iterate  --  Public
  200. ;;;
  201. ;;;    The ultimate iteration macro...
  202. ;;;
  203. (defmacro iterate (name binds &body body)
  204.   "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
  205.   This is syntactic sugar for Labels.  It creates a local function Name with
  206.   the specified Vars as its arguments and the Declarations and Forms as its
  207.   body.  This function is then called with the Initial-Values, and the result
  208.   of the call is return from the macro."
  209.   (dolist (x binds)
  210.     (unless (and (listp x)
  211.          (= (length x) 2))
  212.       (error "Malformed iterate variable spec: ~S." x)))
  213.   
  214.   `(labels ((,name ,(mapcar #'first binds) ,@body))
  215.      (,name ,@(mapcar #'second binds))))
  216.  
  217.  
  218. ;;;; The Collect macro:
  219.  
  220. ;;; Collect-Normal-Expander  --  Internal
  221. ;;;
  222. ;;;    This function does the real work of macroexpansion for normal collection
  223. ;;; macros.  N-Value is the name of the variable which holds the current
  224. ;;; value.  Fun is the function which does collection.  Forms is the list of
  225. ;;; forms whose values we are supposed to collect.
  226. ;;;
  227. (defun collect-normal-expander (n-value fun forms)
  228.   `(progn
  229.     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
  230.     ,n-value))
  231.  
  232. ;;; Collect-List-Expander  --  Internal
  233. ;;;
  234. ;;;    This function deals with the list collection case.  N-Tail is the pointer
  235. ;;; to the current tail of the list, which is NIL if the list is empty.
  236. ;;;
  237. (defun collect-list-expander (n-value n-tail forms)
  238.   (let ((n-res (gensym)))
  239.     `(progn
  240.       ,@(mapcar #'(lambda (form)
  241.             `(let ((,n-res (cons ,form nil)))
  242.                (cond (,n-tail
  243.                   (setf (cdr ,n-tail) ,n-res)
  244.                   (setq ,n-tail ,n-res))
  245.                  (t
  246.                   (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  247.         forms)
  248.       ,n-value)))
  249.  
  250.  
  251. ;;; Collect  --  Public
  252. ;;;
  253. ;;;    The ultimate collection macro...
  254. ;;;
  255. (defmacro collect (collections &body body)
  256.   "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
  257.   Collect some values somehow.  Each of the collections specifies a bunch of
  258.   things which collected during the evaluation of the body of the form.  The
  259.   name of the collection is used to define a local macro, a la MACROLET.
  260.   Within the body, this macro will evaluate each of its arguments and collect
  261.   the result, returning the current value after the collection is done.  The
  262.   body is evaluated as a PROGN; to get the final values when you are done, just
  263.   call the collection macro with no arguments.
  264.  
  265.   Initial-Value is the value that the collection starts out with, which
  266.   defaults to NIL.  Function is the function which does the collection.  It is
  267.   a function which will accept two arguments: the value to be collected and the
  268.   current collection.  The result of the function is made the new value for the
  269.   collection.  As a totally magical special-case, the Function may be Collect,
  270.   which tells us to build a list in forward order; this is the default.  If an
  271.   Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
  272.   end.  Note that Function may be anything that can appear in the functional
  273.   position, including macros and lambdas."
  274.  
  275.   (let ((macros ())
  276.     (binds ()))
  277.     (dolist (spec collections)
  278.       (unless (<= 1 (length spec) 3)
  279.     (error "Malformed collection specifier: ~S." spec))
  280.       (let ((n-value (gensym))
  281.         (name (first spec))
  282.         (default (second spec))
  283.         (kind (or (third spec) 'collect)))
  284.     (push `(,n-value ,default) binds)
  285.     (if (eq kind 'collect)
  286.         (let ((n-tail (gensym)))
  287.           (if default
  288.           (push `(,n-tail (last ,n-value)) binds)
  289.           (push n-tail binds))
  290.           (push `(,name (&rest args)
  291.                 (collect-list-expander ',n-value ',n-tail args))
  292.             macros))
  293.         (push `(,name (&rest args)
  294.               (collect-normal-expander ',n-value ',kind args))
  295.           macros))))
  296.     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
  297.  
  298.  
  299. ;;;; The Once-Only macro:
  300.  
  301. ;;; Once-Only  --  Interface
  302. ;;;
  303. ;;;    Once-Only is a utility useful in writing source transforms and macros.
  304. ;;; It provides an easy way to wrap a let around some code to ensure that some
  305. ;;; forms are only evaluated once.
  306. ;;;
  307. (defmacro once-only (specs &body body)
  308.   "Once-Only ({(Var Value-Expression)}*) Form*
  309.   Create a Let* which evaluates each Value-Expression, binding a temporary
  310.   variable to the result, and wrapping the Let* around the result of the
  311.   evaluation of Body.  Within the body, each Var is bound to the corresponding
  312.   temporary variable."
  313.   (iterate frob
  314.        ((specs specs)
  315.         (body body))
  316.     (if (null specs)
  317.     `(progn ,@body)
  318.     (let ((spec (first specs)))
  319.       (when (/= (length spec) 2)
  320.         (error "Malformed Once-Only binding spec: ~S." spec))
  321.       (let ((name (first spec))
  322.         (exp-temp (gensym)))
  323.         `(let ((,exp-temp ,(second spec))
  324.            (,name (gensym "OO-")))
  325.            `(let ((,,name ,,exp-temp))
  326.           ,,(frob (rest specs) body))))))))
  327.  
  328.  
  329. ;;;; DO-ANONYMOUS:
  330.  
  331. ;;; ### Bootstrap hack...  Renamed to avoid clobbering function in bootstrap
  332. ;;; environment.
  333. ;;;
  334. (defun lisp::do-do-body (varlist endlist code decl bind step name block)
  335.   (let* ((inits ())
  336.      (steps ())
  337.      (l1 (gensym))
  338.      (l2 (gensym)))
  339.     ;; Check for illegal old-style do.
  340.     (when (or (not (listp varlist)) (atom endlist))
  341.       (error "Ill-formed ~S -- possibly illegal old style DO?" name))
  342.     ;; Parse the varlist to get inits and steps.
  343.     (dolist (v varlist)
  344.       (cond ((symbolp v) (push v inits))
  345.         ((listp v)
  346.          (unless (symbolp (first v))
  347.            (error "~S step variable is not a symbol: ~S" name (first v)))
  348.          (case (length v)
  349.            (1 (push (first v) inits))
  350.            (2 (push v inits))
  351.            (3 (push (list (first v) (second v)) inits)
  352.           (setq steps (list* (third v) (first v) steps)))
  353.            (t (error "~S is an illegal form for a ~S varlist." v name))))
  354.         (t (error "~S is an illegal form for a ~S varlist." v name))))
  355.     ;; And finally construct the new form.
  356.     `(block ,BLOCK
  357.        (,bind ,(nreverse inits)
  358.     ,@decl
  359.     (tagbody
  360.      (go ,L2)
  361.      ,L1
  362.      ,@code
  363.      (,step ,@(nreverse steps))
  364.        ,L2 
  365.      (unless ,(car endlist) (go ,L1))
  366.      (return-from ,BLOCK (progn ,@(cdr endlist))))))))
  367.  
  368.  
  369. (defmacro do-anonymous (varlist endlist &body (body decls))
  370.   "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
  371.   Like DO, but has no implicit NIL block.  Each Var is initialized in parallel
  372.   to the value of the specified Init form.  On subsequent iterations, the Vars
  373.   are assigned the value of the Step form (if any) in paralell.  The Test is
  374.   evaluated before each evaluation of the body Forms.  When the Test is true,
  375.   the the Exit-Forms are evaluated as a PROGN, with the result being the value
  376.   of the DO."
  377.   (lisp::do-do-body varlist endlist body decls 'let 'psetq
  378.             'do-anonymous (gensym)))
  379.  
  380.  
  381. ;;;; Hash cache utility:
  382.  
  383. ;;; DEFINE-HASH-CACHE  --  Public
  384. ;;;
  385. (defmacro define-hash-cache (name args &key hash-function hash-bits default
  386.                   (values 1))
  387.   "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
  388.   Define a hash cache that associates some number of argument values to a
  389.   result value.  The Test-Function paired with each Arg-Name is used to compare
  390.   the value for that arg in a cache entry with a supplied arg.  The
  391.   Test-Function must not error when passed NIL as its first arg, but need not
  392.   return any particular value.  Test-Function may be any thing that can be
  393.   place in CAR position.
  394.  
  395.   Name is used to define functions these functions:
  396.  
  397.   <name>-CACHE-LOOKUP Arg*
  398.       See if there is an entry for the specified Args in the cache.  The if not
  399.       present, the :DEFAULT keyword (default NIL) determines the result(s).
  400.  
  401.   <name>-CACHE-ENTER Arg* Value*
  402.       Encache the association of the specified args with Value.
  403.  
  404.   <name>-CACHE-FLUSH-<arg-name> Arg
  405.       Flush all entries from the cache that have the value Arg for the named
  406.       arg.
  407.  
  408.   <name>-CACHE-CLEAR
  409.       Reinitialize the cache, invalidating all entries and allowing the
  410.       arguments and result values to be GC'd.
  411.  
  412.   These other keywords are defined:
  413.  
  414.   :HASH-BITS <n>
  415.       The size of the cache as a power of 2.
  416.  
  417.   :HASH-FUNCTION function
  418.       Some thing that can be placed in CAR position which will compute a value
  419.       between 0 and (1- (expt 2 <hash-bits>)).
  420.  
  421.   :VALUES <n>
  422.       The number of values cached."
  423.       
  424.   (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
  425.      (nargs (length args))
  426.      (entry-size (+ nargs values))
  427.      (size (ash 1 hash-bits))
  428.      (total-size (* entry-size size))
  429.      (default-values (if (and (consp default) (eq (car default) 'values))
  430.                  (cdr default)
  431.                  (list default)))
  432.      (n-index (gensym))
  433.      (n-cache (gensym)))
  434.  
  435.     (unless (= (length default-values) values)
  436.       (error "Number of default values ~S differs from :VALUES ~D."
  437.          default values))
  438.  
  439.     (collect ((inlines)
  440.           (forms)
  441.           (tests)
  442.           (sets)
  443.           (arg-vars)
  444.           (values-indices)
  445.           (values-names))
  446.       (dotimes (i values)
  447.     (values-indices `(+ ,n-index ,(+ nargs i)))
  448.     (values-names (gensym)))
  449.  
  450.       (let ((n 0))
  451.     (dolist (arg args)
  452.       (unless (= (length arg) 2)
  453.         (error "Bad arg spec: ~S." arg))
  454.       (let ((arg-name (first arg))
  455.         (test (second arg)))
  456.         (arg-vars arg-name)
  457.         (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
  458.         (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
  459.         
  460.         (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name)))
  461.           (forms
  462.            `(defun ,fun-name (,arg-name)
  463.           (do ((,n-index ,(+ (- total-size entry-size) n)
  464.                  (- ,n-index ,entry-size))
  465.                (,n-cache ,var-name))
  466.               ((minusp ,n-index))
  467.             (declare (type fixnum ,n-index))
  468.             (when (,test (svref ,n-cache ,n-index) ,arg-name)
  469.               (let ((,n-index (- ,n-index ,n)))
  470.             ,@(mapcar #'(lambda (i val)
  471.                       `(setf (svref ,n-cache ,i) ,val))
  472.                   (values-indices)
  473.                   default-values))))
  474.           (undefined-value)))))
  475.       (incf n)))
  476.     
  477.       (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
  478.     (inlines fun-name)
  479.     (forms
  480.      `(defun ,fun-name ,(arg-vars)
  481.         (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
  482.           (,n-cache ,var-name))
  483.           (declare (type fixnum ,n-index))
  484.           (if (and ,@(tests))
  485.           (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x))
  486.                     (values-indices)))
  487.           ,default)))))
  488.  
  489.       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
  490.     (inlines fun-name)
  491.     (forms
  492.      `(defun ,fun-name (,@(arg-vars) ,@(values-names))
  493.         (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
  494.           (,n-cache ,var-name))
  495.           (declare (type fixnum ,n-index))
  496.           ,@(sets)
  497.           ,@(mapcar #'(lambda (i val)
  498.                 `(setf (svref ,n-cache ,i) ,val))
  499.             (values-indices)
  500.             (values-names))
  501.           (undefined-value)))))
  502.  
  503.       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
  504.     (forms
  505.      `(defun ,fun-name ()
  506.         (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
  507.          (,n-cache ,var-name))
  508.         ((minusp ,n-index))
  509.           (declare (type fixnum ,n-index))
  510.           ,@(collect ((arg-sets))
  511.           (dotimes (i nargs)
  512.             (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
  513.           (arg-sets))
  514.           ,@(mapcar #'(lambda (i val)
  515.                 `(setf (svref ,n-cache ,i) ,val))
  516.             (values-indices)
  517.             default-values))
  518.         (undefined-value)))
  519.     (forms `(,fun-name)))
  520.       
  521.       `(progn
  522.      (defvar ,var-name (make-array ,total-size))
  523.      (proclaim '(type (simple-vector ,total-size) ,var-name))
  524.      (proclaim '(inline ,@(inlines)))
  525.      ,@(forms)
  526.      ',name))))
  527.  
  528.  
  529. ;;; DEFUN-CACHED  --  Public
  530. ;;;
  531. (defmacro defun-cached ((name &rest options &key (values 1) default
  532.                   &allow-other-keys)
  533.             args &body (body decls doc))
  534.   "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
  535.   Some syntactic sugar for defining a function whose values are cached by
  536.   DEFINE-HASH-CACHE."
  537.   (let ((default-values (if (and (consp default) (eq (car default) 'values))
  538.                 (cdr default)
  539.                 (list default)))
  540.     (arg-names (mapcar #'car args)))
  541.     (collect ((values-names))
  542.       (dotimes (i values)
  543.     (values-names (gensym)))
  544.       `(progn
  545.      (define-hash-cache ,name ,args ,@options)
  546.      (defun ,name ,arg-names
  547.        ,@decls
  548.        ,doc
  549.        (multiple-value-bind
  550.            ,(values-names)
  551.            (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
  552.          (if (and ,@(mapcar #'(lambda (val def)
  553.                     `(eq ,val ,def))
  554.                 (values-names) default-values))
  555.          (multiple-value-bind ,(values-names)
  556.                       (progn ,@body)
  557.            (,(symbolicate name "-CACHE-ENTER") ,@arg-names
  558.             ,@(values-names))
  559.            (values ,@(values-names)))
  560.          (values ,@(values-names)))))))))
  561.  
  562.  
  563. ;;; CACHE-HASH-EQ  -- Public
  564. ;;;
  565. (proclaim '(inline cache-hash-eq))
  566. (defun cache-hash-eq (x)
  567.   "Return an EQ hash of X.  The value of this hash for any given object can (of
  568.   course) change at arbitary times."
  569.   (the fixnum (ash (truly-the fixnum (%primitive lisp::make-fixnum x)) -3)))
  570.  
  571.